package Devel::FastProf;

#$SIG{__DIE__} = sub { dump; };

BEGIN {
    $VERSION = '0.08';
}

package DB;     # everything else is defined in the DB (debugger) package

require Storable;

BEGIN {
    # setting $^P non-zero automatically initializes perl debugging internals
    # (mg.c calls init_debugger) if $DB::single is false. This is handy for
    # situations like mod_perl where perl wasn't started with -d flag.
    $^P=0x1;    # on
    $^P=0x0;    # then back off again for now, see below
}


our %sub_callers;
our %fastprof_config;

BEGIN {

    $Devel::FastProf::granularity = 1;

    eval "require Time::HiRes"; # try to load before we bootstrap ourselves

    require XSLoader;
    XSLoader::load('Devel::FastProf', $Devel::FastProf::VERSION);

    if ($] < 5.008008) { # workaround bug in old perl versions
        local $^W = 0;
	*DB_orig = \&DB; *DB = sub { goto &DB_orig };
	#*sub_orig = \&sub; *sub = sub { goto &sub_orig };
    }
    *sub = \&sub__perl; # sub__xs is incomplete so use perl version

    %fastprof_config = (
        filename => 'fastprof.out',
        usecputime => 0,
        canfork => 0,
    );

    for (split /\s*,\s*/, $ENV{FASTPROF_CONFIG}||'') {
        my ($key, $value) = (/^(.*?)\s*=\s*(.*)$/) ? ($1, $2) : ($_, 1);
        warn "FASTPROF_CONFIG unknown config name '$key'\n"
            if not exists $fastprof_config{$key};
        $fastprof_config{$key} = $value;
    }

    $Devel::FastProf::granularity = $fastprof_config{granularity};
    my $fn = $fastprof_config{filename};
    my $cf = $fastprof_config{canfork};
    if ($cf) {
	unless ($fn =~ m|^/|) {
	    # Oh, yes!
	    # I know about Cwd, but I don't want
	    # to load external modules here!!!
	    chomp(my $pwd = `pwd`);
	    $fn = "$pwd/$fn";
	}
    }

    _init($fn, $fastprof_config{usecputime}, $cf);

    $^P = 0x002  # Line-by-line debugging
	#| 0x001  # Record subroutine callers (optional)
        #| 0x040
        | 0x100; # Give "file" names to evals based on where compiled

    # Start with single-step on, unless in mod_perl
    $^P |= 0x020
	unless $ENV{MOD_PERL};

    #warn sprintf "\$^P=0x%04x\n", $^P;

=for comment from perlvar

       $^P     The internal variable for debugging support.  The meanings of
               the various bits are subject to change, but currently indicate:

               0x01  Debug subroutine enter/exit.

               0x02  Line-by-line debugging.

               0x04  Switch off optimizations.

               0x08  Preserve more data for future interactive inspections.

               0x10  Keep info about source lines on which a subroutine is
                     defined.

               0x20  Start with single-step on.

               0x40  Use subroutine address instead of name when reporting.

               0x80  Report "goto &subroutine" as well.

               0x100 Provide informative "file" names for evals based on the
                     place they were compiled.

               0x200 Provide informative names to anonymous subroutines based
                     on the place they were compiled.

               0x400 Debug assertion subroutines enter/exit.

               Some bits may be relevant at compile-time only, some at run-
               time only.  This is a new mechanism and the details may change.
=cut

}


sub sub__perl {
    if ($DB::single) { # we're single-stepping - so we're interested in this call

	# CODE refs aren't very useful individually so aggregate them
	my $node = $sub_callers{ ref($sub) || $sub } ||= {};

	#do { local $^W; warn "$sub caller: ".join(", ", caller(0))."\n" };

	# XXX splitting into {$filename}{$line} would use much less memory

	# optional: add extra level to tree
	my $depth = 0;
	$node = $node->{ join(":", (caller($depth++))[1,2]) } ||= {};

	(undef, my $filename, my $line) = caller($depth++);
	$node->{"$filename:$line"}++
	    if defined $line    # subs called from main script don't have caller info, odd
    }
    return &$sub;
}

sub dump_sub_callers {
    my $sub_callers = shift;
    my $dir = "/tmp/fastprof.callers";
    warn "Dumping sub callers ($$) to $dir\n";
    Storable::nstore(\%sub_callers, $dir);
    %sub_callers = ();
    return;

    mkdir $dir or die "Can't mkdir $dir: $!"
	unless -d $dir;
    for my $sub (sort keys %$sub_callers) {
        my $files = $sub_callers->{$sub};
        (my $outfile = $sub) =~ s/[^\w:]/-/g;
        my $out = "$dir/$outfile.callers";
        open my $fh, ">$out"
            or warn("Can't write to $out: $!"),next;
        warn "$out\n";
        print $fh "# $sub callers, sorted by frequency\n";
        for my $file (sort { $files->{$b} <=> $files->{$a} or $a cmp $b } keys %$files) {
            my $count = $files->{$file};
            print $fh "$file: $count\n";
        }
        close $fh or warn "Error writing to $out: $!";
    }
}

END {
    { package main; 1 }
    _finish();
    dump_sub_callers(\%sub_callers) if %sub_callers;
}

1;


__END__

=head1 NAME

Devel::FastProf - "fast" perl per-line profiler

=head1 SYNOPSIS

  $ perl -d:FastProf my_script.pl
  $ fprofpp -t 10

=head1 ABSTRACT

Devel::FastProf tells you how much time has been spent on every line
of your program.

=head1 DESCRIPTION

C<Devel::FastProf> is a perl per-line profiler. What that means is
that it can tell you how much time is spent on every line of a perl
script (the standard L<Devel::DProf> is a per-subroutine profiler).

I have been the maintainer of L<Devel::SmallProf> for some time and
although I found it much more useful that L<Devel::DProf>, it had an
important limitation: it was terribly slow, around 50 times slower
than the profiled script being run out of the profiler.

So, I rewrote it from scratch in C, and the result is
C<Devel::FastProf>, that runs only between 3 and 5 times slower than
under normal execution... well, maybe I should have called it
C<Devel::NotSoSlowProf> ;-)

To use C<Devel::FastProf> with your programs, you have to call perl
with the C<-d> switch (see L<perlrun>) as follows:

  $ perl -d:FastProf my_script.pl

C<Devel::FastProf> will write the profiling information to a file
named C<fastprof.out> under the current directory.

To analyse the information on this file use the post processor script
L<fprofpp> included with this package.

Some options can be passed to C<Devel::FastProf> via the environment
variable C<FASTPROF_CONFIG>:

=over 4

=item filename=otherfn.out

allows to change the name of the output file.

=item usecputime

by default, C<Devel::FastProf> meassures the wall clock time spent on
every line, but if this entry is included it will use the cpu time
(user+system) instead.

=item canfork

this option has to be used if the profiled script forks new processes,
if you forget to do so, a corrupted C<fastprof.out> file could be generated.

Activating this mode causes a big performance penalty because write
operations from all the processes have to be serialized using
locks. That is why it is not active by default.

=back

This is an example of how to set those options:

  $ FASTPROF_CONFIG="usecputime,filename=/tmp/fp.out" \
      perl -d:FastProf myscript.pl

=head1 TIMING

Time is measured from start of one perl statement to the start of the next.
That's roughly equivalent to one semi-colon to the next.

=head1 CAVEATS

The time for the last statement executed in a subroutine includes the time
spent by perl doing any housekeeping, such as freeing memory for temporary
valuables, before it reaches the next I<perl statement>.

Consider this example:

    foo(), some_builtin_or_xs_sub() for 1..10;

Because some_builtin_or_xs_sub() doesn't invoke any perl statements, the time
spent in some_builtin_or_xs_sub() (and the oveheads  of the loop itself) will
appear in the profile at the last statement in foo().

=head1 BUGS

No Windows! No threads!

Only tested on Linux and Mac OS X. It is know not to work under Solaris.

The code of subroutines defined inside C<eval "..."> constructions
that do not include any other code will not be available on the
reports. This is caused by a limitation on the perl interpreter.

Option -g is buggy, it only works when all the modules are loaded in
the original process.

Perl 5.8.8 or later is recomended. Older versions have a bug that
cause this profiler to be slower.

If you find any bug, please, send me an e-mail to
L<sfandino@yahoo.com> or report it via the CPAN RT system.

=head1 SEE ALSO

L<fprofpp>, L<perlrun>, L<Devel::SmallProf>, L<Devel::Dprof>,
L<perldebug> and L<perldebguts>.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005-2007 by Salvador FandiE<ntilde>o
E<lt>sfandino@yahoo.comE<gt>.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.

=cut
